home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_pcdp / adas / util.pas < prev   
Pascal/Delphi Source File  |  1996-01-30  |  12KB  |  473 lines
  1. unit util;
  2.  
  3.   { Utility programs: lexical analyzer and
  4.      compiler table manipulation }
  5.  
  6. interface
  7. uses global;
  8. procedure nextch;
  9. procedure error(n: er);
  10. procedure fatal(n: integer);
  11. procedure insymbol;
  12. procedure enterst(x0: alfa; x1: object; x2: types; x3:integer);
  13. function loc(level: integer; id: alfa): integer;
  14. procedure enter(id: alfa; k: object; level: integer);
  15. procedure enterarray(tp: types; l,h: integer);
  16. procedure enterblock;
  17. procedure emit(fct: integer);
  18. procedure emit1(fct, b: integer);
  19. procedure emit2(fct, a, b: integer);
  20. procedure printinst(var f: text; i: integer);
  21. procedure initutil;
  22.  
  23. var
  24.   { The following variables are used by the various
  25.     units comprising the compiler }
  26.  
  27.   inp:     text;    { input file }
  28.   list:    text;    { list file }
  29.   listing: boolean; { listing flag }
  30.   sy:      symbol;  { current symbol }
  31.   id:      alfa;    { name of current identifier }
  32.   inum:    integer; { value of integer constant }
  33.   sleng:   integer; { length of string constant }
  34.   a:       integer; { array counter }
  35.   b:       integer; { block counter }
  36.   t:       integer; { symbol table index }
  37.   lc:      integer; { location counter in code table }
  38.  
  39. const
  40.  
  41.   { keywords must be in alphabetical order for binary search }
  42.   key: array[1..nkw] of alfa = (
  43.      'accept    ' , 'and       ' , 'array     ' , 'begin     ' ,
  44.      'body      ' , 'constant  ' , 'do        ' , 'else      ' ,
  45.      'elsif     ' , 'end       ' , 'exit      ' , 'for       ' ,
  46.      'if        ' , 'in        ' , 'is        ' , 'loop      ' ,
  47.      'mod       ' , 'not       ' , 'null      ' , 'of        ' ,
  48.      'or        ' , 'out       ' , 'pragma    ' , 'procedure ' ,
  49.      'select    ' , 'task      ' , 'terminate ' , 'then      ' ,
  50.      'type      ' , 'when      ' , 'while     '
  51.        );
  52.  
  53.   { this table of symbols must match the above table of keywords }
  54.   ksy: array[1..nkw] of symbol = (
  55.      acceptsy,  andsy,    arraysy,   beginsy,
  56.      bodysy,    constsy,  dosy,      elsesy,
  57.      elsif,     endsy,    exitsy,    forsy,
  58.      ifsy,      insy,     issy,      loopsy,
  59.      imod,      notsy,    nullsy,    ofsy,
  60.      orsy,      outsy,    pragmasy,  proceduresy,
  61.      selectsy,  tasksy,   terminate, thensy,
  62.      typesy,    when,     whilesy
  63.      );
  64.  
  65. const
  66.   constbegsys : symset = [plus, minus, intcon, charcon, ident];
  67.   typebegsys  : symset = [ident, arraysy];
  68.   blockbegsys : symset = [constsy, typesy, proceduresy,
  69.                           beginsy, tasksy];
  70.   facbegsys   : symset = [intcon, charcon, ident, lparent, notsy];
  71.   statbegsys  : symset = [ident, beginsy, ifsy, whilesy, loopsy,
  72.                           acceptsy, exitsy, forsy, selectsy, nullsy];
  73.  
  74. implementation
  75.  
  76. var
  77.   line:   array[1..llng] of char;
  78.   cc:     integer;  { character counter within input line }
  79.   ll:     integer;  { length of line as read from input }
  80.   savell: integer;  { saved ll for error message }
  81.   sx:     integer;  { current end of string table }
  82.   ch:     char;     { last character read }
  83.  
  84. const
  85.   fatalmsg: array[1..7] of alfa = (
  86.      'identifer ', 'procedures', 'strings   ',  'arrays    ',
  87.      'levels    ', 'code      ', 'entries   ' );
  88.  
  89. procedure initutil;
  90. begin
  91.   lc := 0;
  92.   cc := 0;
  93.   ll := 0;
  94.   sx := 0;
  95.   ch := ' '
  96. end;
  97.  
  98. procedure nextch;
  99.   { returns next character in ch, checking for eol and eof }
  100. begin
  101.   if cc=ll then
  102.     begin
  103.     if eof(inp) then
  104.       begin
  105.       writeln;
  106.       writeln('program incomplete');
  107.       if listing then close(list);
  108.       halt
  109.       end;
  110.     if listing then write(list, lc:5, ' ');
  111.     savell := ll;
  112.     ll := 0;
  113.     cc := 0;
  114.     while not eoln(inp) do
  115.       begin
  116.       ll := ll + 1;
  117.       read(inp, ch);
  118.       if ch < ' ' then ch := ' ';
  119.       if listing then write(list, ch);
  120.       line[ll] := ch
  121.       end;
  122.     if listing then writeln(list);
  123.     ll := ll + 1;
  124.     read(inp, line[ll]);
  125.     if line[ll] < ' ' then line[ll] := ' ';
  126.     end;
  127.   cc := cc + 1;
  128.   ch := line[cc]
  129. end;
  130.  
  131. procedure error(n: er);
  132.   { print error code and halt }
  133. var i: integer;
  134. begin
  135.   if listing then
  136.     begin
  137.     write(list, '*****', ' ':cc, '^', ord(n):2);
  138.     close(list)
  139.     end;
  140.   writeln('Compilation error:');
  141.   for i := 1 to ll do write(line[i]);
  142.   writeln;
  143.   writeln(' ':cc-1, '^', ord(n):2);
  144.   readln;
  145.   halt
  146. end;
  147.  
  148. procedure fatal(n: integer);
  149.   { print fatal error and halt }
  150. begin
  151.   writeln;
  152.   writeln('compiler table for ', fatalmsg[n], ' is too small');
  153.   readln;
  154.   halt
  155. end;
  156.  
  157. procedure insymbol;
  158.   { lexical analyzer: get next symbol and return in sy
  159.       also set id, inum, sleng, as needed }
  160. label 1,2,3;
  161. var i,j,k,e: integer;
  162.   quotech: char;
  163. begin
  164. 1:while ch = ' ' do nextch;
  165.   case ch of
  166.   'a'..'z', 'A'..'Z':
  167.     begin
  168.     k := 0;
  169.     id := '          ';
  170.     repeat
  171.       if k < alng then   { use only alng chars of identifier }
  172.         begin
  173.         k := k + 1;
  174.         if ch in ['A'..'Z']
  175.          then
  176.           id[k] := chr(ord(ch)+ord('a')-ord('A'))
  177.         else id[k] := ch
  178.         end;
  179.       nextch
  180.     until not (ch in ['a'..'z', 'A'..'Z', '0'..'9', '_']);
  181.     i := 1;
  182.     j := nkw;
  183.     repeat     { binary search for keywords }
  184.       k := (i+j) div 2;
  185.       if id <= key[k] then j := k-1;
  186.       if id >= key[k] then i := k+1;
  187.     until i > j;
  188.     if i-1 > j then sy := ksy[k] else sy := ident
  189.     end;
  190.   '0'..'9':   { convert numerals to numbers }
  191.     begin
  192.     k := 0;
  193.     inum := 0;
  194.     sy := intcon;
  195.     repeat
  196.       inum := inum*10 + ord(ch) - ord('0');
  197.       k := k + 1;
  198.       nextch
  199.     until not (ch in ['0'..'9']);
  200.     if k>kmax then
  201.       begin
  202.       error(erln);
  203.       inum := 0;
  204.       k := 0
  205.       end;
  206.     end;
  207.  
  208.   ':':
  209.     begin
  210.     nextch;
  211.     if ch = '=' then begin sy := becomes; nextch end
  212.     else sy := colon
  213.     end;
  214.  
  215.   '<':
  216.     begin
  217.     nextch;
  218.     if ch = '=' then begin sy := leq; nextch end
  219.     else sy := lss
  220.     end;
  221.  
  222.   '/':
  223.     begin
  224.     nextch;
  225.     if ch = '=' then begin sy := neq; nextch end
  226.     else sy := idiv
  227.     end;
  228.  
  229.   '>':
  230.     begin
  231.     nextch;
  232.     if ch = '=' then begin sy := geq; nextch end
  233.     else sy := gtr
  234.     end;
  235.  
  236.   '"', '''':   { characters and strings }
  237.     begin
  238.     quotech := ch;
  239.     k := 0;
  240.     2: nextch;
  241.     if ch = quotech then
  242.       begin
  243.       nextch;
  244.       if ch <> quotech then goto 3
  245.       end;
  246.     if sx + k = smax then fatal(3);
  247.     stab[sx+k] := ch;
  248.     k := k + 1;
  249.     if cc = 1 then k := 0
  250.     else goto 2;
  251.     3: if (k = 1) and (quotech = '''')  then
  252.       begin
  253.       sy := charcon;
  254.       inum := ord(stab[sx]);
  255.       end
  256.     else if (k = 0) or (quotech = '''')  then
  257.       begin
  258.       error(ersh);
  259.       sy := charcon;
  260.       inum := 0
  261.       end
  262.     else begin
  263.       sy := strng;
  264.       inum := sx;
  265.       sleng := k;
  266.       sx := sx + k
  267.       end
  268.     end;
  269.  
  270.   '-':  { -- starts a comment, ignore rest of line }
  271.     begin
  272.     nextch;
  273.     if ch <> '-' then sy := minus else
  274.       begin cc := ll; nextch; goto 1 end
  275.     end;
  276.  
  277.   '=':
  278.        begin
  279.        nextch;
  280.        if ch = '>' then begin sy := arrow; nextch end
  281.        else sy := eql
  282.        end;
  283.  
  284.   '.':
  285.        begin
  286.        nextch;
  287.        if ch = '.' then begin sy := colon; nextch end
  288.        else sy := period
  289.        end;
  290.  
  291.   '+': begin sy := plus;      nextch end;
  292.   '(': begin sy := lparent;   nextch end;
  293.   '*': begin sy := times;     nextch end;
  294.   ')': begin sy := rparent;   nextch end;
  295.   ',': begin sy := comma;     nextch end;
  296.   ';': begin sy := semicolon; nextch end;
  297.  
  298.   else
  299.     begin
  300.     error(erch);
  301.     nextch;
  302.     goto 1
  303.     end
  304.   end (* case *);
  305. end;
  306.  
  307. procedure enterst(x0: alfa; x1: object; x2: types; x3: integer);
  308.   { enter a pre-defined symbol into the symbol table }
  309. begin
  310.   t := t + 1;
  311.   with tab[t] do
  312.     begin
  313.     name := x0;
  314.     link := t - 1;
  315.     obj := x1;
  316.     typ := x2;
  317.     ref := 0;
  318.     normal := true;
  319.     lev := 0;
  320.     adr := x3
  321.     end
  322. end;
  323.  
  324. procedure enterarray(tp: types; l,h: integer);
  325.   { enter an array into the array table }
  326. begin
  327.   if l > h then error(ertyp);
  328.   if a = amax then fatal(4);
  329.   a := a + 1;
  330.   with atab[a] do
  331.     begin
  332.     inxtyp := tp;
  333.     low := l;
  334.     high := h
  335.     end
  336. end;
  337.  
  338. procedure enterblock;
  339.   { enter a block into the block table }
  340. begin
  341.   if b = bmax then fatal(2);
  342.   b := b + 1;
  343.   btab[b].last := 0;
  344.   btab[b].lastpar := 0
  345. end;
  346.  
  347. procedure emit(fct: integer);
  348.   { emit a parameterless instruction into the code table }
  349. begin
  350.   if lc = cmax then fatal(6);
  351.   code[lc].f := fct;
  352.   if listing then
  353.     begin
  354.     write(list, lc:10, '   ');
  355.     printinst(list, fct);
  356.     writeln(list, fct:5);
  357.     end;
  358.   lc := lc + 1
  359. end;
  360.  
  361. procedure emit1(fct, b: integer);
  362.   { emit a one-parameter instruction }
  363. begin
  364.   if lc = cmax then fatal(6);
  365.   with code[lc] do
  366.     begin
  367.     f := fct;
  368.     y := b
  369.     end;
  370.   if listing then
  371.     begin
  372.     write(list, lc:10,'   ');
  373.     printinst(list, fct);
  374.     writeln(list, fct:5,b:5);
  375.     end;
  376.   lc := lc + 1
  377. end;
  378.  
  379. procedure emit2(fct, a, b: integer);
  380.   { emit a two-parameter instruction }
  381. begin
  382.   if lc = cmax then fatal(6);
  383.   with code[lc] do
  384.     begin
  385.     f := fct;
  386.     x := a;
  387.     y := b
  388.     end;
  389.   if listing then
  390.     begin
  391.     write(list, lc:10, '   ');
  392.     printinst(list, fct);
  393.     writeln(list, fct:5,a:5,b:5);
  394.     end;
  395.   lc := lc + 1
  396. end;
  397.  
  398. procedure enter(id: alfa; k: object; level: integer);
  399.   { enter a symbol into the symbol table,
  400.       checking down the link fields to see if the symbol
  401.       is duplicated AT THE SAME LEVEL }
  402. var j,l: integer;
  403. begin
  404.   if t = tmax then fatal(1);
  405.   tab[0].name := id;
  406.   j := btab[display[level]].last;
  407.   l := j;
  408.   while tab[j].name <> id do
  409.     j := tab[j].link;
  410.   if j <> 0 then error(erdup);
  411.   t := t + 1;
  412.   with tab[t] do
  413.     begin
  414.     name := id;
  415.     link := l;
  416.     obj := k;
  417.     typ := notyp;
  418.     ref := 0;
  419.     lev := level;
  420.     adr := 0
  421.     end;
  422.   btab[display[level]].last := t
  423. end;
  424.  
  425. function loc(level: integer; id: alfa): integer;
  426.   { see if a name has been defined,
  427.       including at lower (more global) levels }
  428. var i,j: integer;
  429. begin
  430.   i := level;
  431.   tab[0].name := id;
  432.   repeat
  433.     j := btab[display[i]].last;
  434.     while tab[j].name <> id do
  435.       j := tab[j].link;
  436.     i := i - 1
  437.   until (i < 0) or (j <> 0);
  438.   loc := j
  439. end;
  440.  
  441. procedure printinst(var f: text; i: integer);
  442.   { print the name of a byte code instruction }
  443. begin
  444.   case i of
  445.         0..2, 24, 34:    write(f, 'load      ');
  446.         3:               write(f, 'display   ');
  447.         4:               write(f, 'cobegin   ');
  448.         5:               write(f, 'coend     ');
  449.         6:               write(f, 'wait      ');
  450.         7:               write(f, 'signal    ');
  451.         10:              write(f, 'jump      ');
  452.         11:              write(f, 'cond jump ');
  453.         14,15:           write(f, 'for       ');
  454.         18:              write(f, 'mark stack');
  455.         19:              write(f, 'call proc ');
  456.         21:              write(f, 'index     ');
  457.         31:              write(f, 'end prog  ');
  458.         32:              write(f, 'end proc  ');
  459.         38:              write(f, 'store     ');
  460.         35, 36, 45..59:  write(f, 'ALU       ');
  461.         27..29, 62,63:   write(f, 'I/O       ');
  462.         74:              write(f, 'call entry');
  463.         75:              write(f, 'accept    ');
  464.         70..73, 76..79:  write(f, 'entry parm');
  465.         80:              write(f, 'end accept');
  466.         81:              write(f, 'select    ');
  467.         82:              write(f, 'terminate ');
  468.         83:              write(f, 'end select');
  469.         else             write(f, '          ')
  470.    end
  471. end;
  472.  
  473. end.